home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / U. Mass AI & LISP Tools / INTERFACE / Hyper-Display.lisp < prev   
Encoding:
Text File  |  1990-06-24  |  34.4 KB  |  728 lines  |  [TEXT/CCL ]
  1. ; (c) Copyright 1990 by University of Massachusetts. All rights reserved.
  2. ; This software was conceived, designed, and written by Dan Suthers 
  3. ; while supported by the National Science Foundation under grant number
  4. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  5. ; CA.  Partial support was also received from the Office of Naval Research
  6. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  7. ; Mr. Suthers created this software under his own initiative while in an 
  8. ; academic relationship with the University of Massachusetts.  The above
  9. ; copyright notice was a condition placed by University lawyers on approval
  10. ; of distribution of this software by Apple Computer, and is not meant to
  11. ; imply that this software was created in an employment or "work for hire"
  12. ; relationship between the University and Mr. Suthers.
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; File:         Hyper-Display.lisp
  15. ; Author:       Dan Suthers
  16. ; Created:      15-Apr-89 14:07:15
  17. ; Modified:     24-Jun-90 02:11:26 (Dan Suthers)
  18. ; Language:     Common Lisp
  19. ; Package:      USER
  20. ;
  21. ; Description:  A Hyper-text like display and browsing interface. The 
  22. ; application provides a hierarchically structured representation of 
  23. ; some text, and command functions.  Regions of text (possibly nested) 
  24. ; have structures with pointers to application data structures associated 
  25. ; with them.  Hyper-Display displays the text in a specialized Fred window.
  26. ; When the user selects a range of the text with a mouse, Hyper-Display is 
  27. ; able to determine the smallest structure in the hierarchy which encloses 
  28. ; that region.  When the user initiates a query on this selected region of 
  29. ; text, the command function is called on the structure representing the 
  30. ; selected region.  For example, a command could be a request to define a
  31. ; term, and the function could replace the text in the window with a 
  32. ; definition, preserving a pointer to the previous hyper-structure, so
  33. ; that another command can return to the original text if desired.
  34. ;
  35. ; (c) Copyright 1989, by Daniel D. Suthers
  36. ;                        Department of Computer and Information Science
  37. ;                        University of Massachusetts
  38. ;                        Amherst, Massachusetts 01003
  39. ; All rights reserved.
  40. ;
  41. ; This software was conceived, designed, and written by Dan Suthers 
  42. ; while supported by the National Science Foundation under grant number
  43. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  44. ; CA.  Partial support was also received from the Office of Naval Research
  45. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  46. ; I wish to acknowledge the generous support of Beverly Woolf, who obtained 
  47. ; the above grants and encouraged me to pursue my own research interests in
  48. ; her lab.  This work would not have been possible without the resources and
  49. ; stimulating environment of the Computer and Information Science department.
  50. ;
  51. ; Permission to use, modify, and distribute this software is granted subject 
  52. ; to the following restrictions and understandings:
  53. ; 1. The file header, including this notice, shall be retained, and may be
  54. ;    extended to include documentation of modifications to the software.
  55. ; 2. This material is for nonprofit educational and research purposes only.
  56. ;    Users are requested, but not required, to inform Mr. Suthers of any 
  57. ;    noteworthy uses of this software.
  58. ; 3. Mr. Suthers and the University of Massachusetts make no warantee or
  59. ;    representation that the operation of this software will be error free,
  60. ;    and are under no obligation to provide any services.
  61. ; 4. Any user of such software agrees to indemnify and hold harmless Mr.
  62. ;    Suthers and the University of Massachusetts from all claims arising 
  63. ;    out of the use or misuse of this software, or arising out of any 
  64. ;    accident, injury, or damage whatsoever, and from all costs, counsel
  65. ;    fees, and liabilities incurred in or about any such claim, action, or
  66. ;    proceeding brought thereon.
  67. ; 5. All materials and reports developed as a consequence of the use of 
  68. ;    this software shall duly acknowledge such use, in accordance with
  69. ;    the usual standards of acknowledging credit in academic research.
  70. ;
  71. ; Status:       A prototype version, but working fine.
  72. ;
  73. ; Tested:       Macintosh II Coral/Allegro 16-Apr-89 15:49:59 Dan Suthers
  74. ;
  75. ; Changes:      
  76. ;   24-Jun-90 DS Temporary hack around table search problem; see @ BUG.
  77. ;
  78. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  79. ;
  80. ;                      DOCUMENTATION FOR EXTERNAL USERS
  81. ;
  82. ; The User's View:
  83. ;
  84. ; The user sees something looking like a Fred window with text displayed 
  85. ; in it.  The user may move and resize the window, use the scroll bars,
  86. ; and select regions with the mouse.  The contents of the window cannot
  87. ; be altered: a beep and a pop-up message window responds to attempts to
  88. ; do so (or to undefined keystrokes).  Only a small number of keys, in
  89. ; particular including the Help key, may be meaningfully used.
  90. ;
  91. ; A Hyper-Display window may have zero or more commands associated with it
  92. ; for operating on selected regions. (It is up to the application whether
  93. ; these commands expand the region into a new hypertext structure to be
  94. ; displayed, or performs some other operation.) The user can always access 
  95. ; any of these commands by using the Help key.  If there is no selected 
  96. ; region, this key pops up a general description of how to use HyperDisplay.
  97. ; If there is a selection, Help puts up a menu of defined commands.  Some 
  98. ; commands may have other keystrokes associated with them, for direct access 
  99. ; without using the menu.  The activated command is applied to the smallest 
  100. ; region enclosing the currently selected text, or to the next region if
  101. ; there is no selection.
  102. ;
  103. ; The Client Program's View:
  104. ;
  105. ; To create a Hyper-Display, the application must give a hyper-structure and
  106. ; a set of commands to the function CREATE-HYPER-DISPLAY.  
  107. ;
  108. ; A Hyper-structure is a Common Lisp structure. (The program interface is
  109. ; designed so that client programs may be written in pure Common Lisp, 
  110. ; not being forced to deal with the object language used to implement this.)
  111. ; It has three client-accessible fields:
  112. ;   Text-Specs: a list of strings and/or recursive hyper-structures.  
  113. ;     The text string to be displayed in the window is constructed by 
  114. ;     traversing the top level text-specs, concatenating strings and 
  115. ;     recursively converting embedded hyper-structures into text.
  116. ;   Parent: backpointer to the hyper-structure whose text-specs this
  117. ;     structure is embedded in.  Note: the present code makes no use
  118. ;     of this slot, and does not attempt to guarantee that its contents
  119. ;     are correct.  Its maintenance is up to the application.
  120. ;   Object: a pointer to the application-specific data structure the text
  121. ;     corresponds to. This is presumably used by the command functions to
  122. ;     respond to queries, e.g. if the object is a node in a text plan, 
  123. ;     then a "define" query may be responded to by displaying text
  124. ;     defining the associated concept.
  125. ;
  126. ; The application specifies the commands as a list of tuples:
  127. ;   ( (<key> <description> <method>) *)
  128. ; where:
  129. ;   <key> is a character specifying the command key which invokes the 
  130. ;     command (#\^E for Help if the command is only available on the menu)
  131. ;   <description> is a short string describing the command (appropriate
  132. ;     for menu display)
  133. ;   <method> is a lambda form or function of two arguments which performs 
  134. ;      the desired operation.  The arguments are the most specific hyper-
  135. ;      structure which includes the text the user selected, and the window
  136. ;      object containing the text.
  137. ;
  138. ; External Functions:
  139. ; 
  140. ; CREATE-HYPER-DISPLAY is given the hyper-structure and command list, and
  141. ;   creates and returns a window object, which should be retained for 
  142. ;   other functions operating on the window. 
  143. ; 
  144. ; DISPLAY-HYPER-STRUCTURE sets a window's hyper-structure to one specified,
  145. ;   and sets the window's buffer to the resulting text, so that is will be
  146. ;   displayed if and when the window is visible. 
  147. ;
  148. ; MAKE-HYPER-STRUCTURE, HYPER-STRUCTURE-TEXT-SPECS, HYPER-STRUCTURE-PARENT,
  149. ; HYPER-STRUCTURE-OBJECT, COPY-HYPER-STRUCTURE, and HYPER-STRUCTURE-P: 
  150. ;   Defined by defstruct.
  151. ;
  152. ; HYPER-STRUCTURE-TEXT: returns a string constructed from recursive 
  153. ;   traversal of the hyper-structure-specs.  Useful for debugging.
  154. ;
  155. ; The application is responsible for other features such as maintaining
  156. ; context stacks of hyper-structures for push/pop facilities, etc. 
  157. ;
  158. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  159. ;
  160. ;                           Pending Improvements:
  161. ;
  162. ; Fix mouse click bug so window-mouse-up-event-handler called inside text
  163. ; region (not just mini-buffer). (However, there may be an advantage to
  164. ; leaving it this way: commands that want to know *exactly* what is 
  165. ; selected can operate.)
  166. ; 
  167. ; Rewrite to not construct a string of the entire buffer's text.  Instead,
  168. ; write the text into the buffer on the fly.  Then I don't need to risk
  169. ; modifying strings with trim-right-margin, and it is faster.
  170. ;
  171. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  172.  
  173. (in-package :HYPER-DISPLAY)
  174.  
  175. (use-package :CCL)
  176.  
  177. (export '(
  178.           *Hyper-Display-window*
  179.  
  180.           create-hyper-display
  181.           display-hyper-structure
  182.  
  183.           hyper-structure
  184.           copy-hyper-structure
  185.           hyper-structure-object
  186.           hyper-structure-p
  187.           hyper-structure-parent
  188.           hyper-structure-text
  189.           hyper-structure-text-specs
  190.           make-hyper-structure
  191.  
  192.           ))
  193.  
  194. (require :DIALOGUE)
  195.  
  196. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  197. ;;;
  198. ;;;                             PARAMETERS
  199. ;;;
  200. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  201.  
  202. (eval-when (compile eval)
  203.  
  204.   (defconstant *DEFAULT-RIGHT-MARGIN* 75)
  205.  
  206.   (defconstant *DEFAULT-MINI-BUFFER-UNSELECTED-MESSAGE*
  207.     "Use Help key for instructions.")
  208.  
  209.   (defconstant *DEFAULT-MINI-BUFFER-SELECTED-MESSAGE*
  210.     "Use Help key for menu of commands.")
  211.  
  212.   (defconstant *DEFAULT-MENU-MESSAGE*
  213.     "Choose an action to apply to your selection:")
  214.  
  215.   (defconstant *READ-ONLY-MESSAGE*
  216.     "Hyper-Display windows are Read-Only (the text can't
  217. be modified).  Push the Help key for instructions.")
  218.  
  219.   (defconstant *DEFAULT-GENERAL-INSTRUCTIONS*
  220.     "You are using a HyperDisplay window, which allows you to perform
  221. certain actions on the displayed text.  To use the display, first
  222. use the mouse to select the text you have a question about or want
  223. to perform an action on.  (Do this the usual way: holding down the
  224. mouse and moving it across the text.  You don't have to select all
  225. of the region exactly, you only have to select most of it and the
  226. HyperDisplay will use the smallest region enclosing what you have
  227. selected.)  Then press the Help key.  You will be shown a menu of 
  228. actions you can take: select the one desired.  Some actions can be 
  229. invoked directly by keystrokes: there is an option on the Help menu 
  230. to find out what these keystrokes are.  The contents of this window 
  231. cannot be modified, except by the defined actions.")
  232.  
  233.   ) ; eval-when
  234.  
  235. (defconstant *HYPER-DISPLAY-PACKAGE* (find-package :hyper-display))
  236.  
  237. (defvar *WINDOW-NAME-COUNTER* 0)
  238.  
  239. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  240. ;;;
  241. ;;;                               DATA TYPES
  242. ;;;
  243. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  244. ;;; Hyper-Structures
  245.  
  246. (defstruct HYPER-STRUCTURE
  247.   (TEXT-SPECS nil    :type list)
  248.   (PARENT     nil    :type hyper-structure)
  249.   (OBJECT     nil)
  250.   (SELECTION-START 0 :type fixnum)  ; Boundaries of buffer substring within
  251.   (SELECTION-END   0 :type fixnum)) ; which the structure is displayed.
  252.  
  253. ;;; This makes the structure appear to have another slot: the expansion of
  254. ;;; the text-specs.  Not used by the present code, but very useful.
  255.  
  256. (defun HYPER-STRUCTURE-TEXT (hs)
  257.   "hyper-structure-text <hyper-structure>
  258.   Returns the string which would be displayed for the given structure."
  259.   (declare (type hyper-structure hs) 
  260.            (optimize (safety 1) (space 2) (speed 3)))
  261.   ;; Reduce list of strings to one string.
  262.   (reduce #'(lambda (s1 s2)
  263.               (declare (string s1 s2))
  264.               (concatenate 'string s1 s2))
  265.           ;; Get a list of strings (all recursive specs expanded).
  266.           (mapcar #'(lambda (spec)
  267.                       (if (stringp spec) 
  268.                         spec
  269.                         (hyper-structure-text spec)))
  270.                   (hyper-structure-text-specs hs))
  271.           :initial-value ""))
  272.  
  273. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  274. ;;; Region-Tables
  275. ;;;
  276. ;;; Region-tables are nested lists which enable a fast mapping from the
  277. ;;; start and end of a selected region of text in the buffer to the smallest
  278. ;;; underlying hyper-structure which includes the selected region.  Padding
  279. ;;; of one character is allowed on each side of the region's actual text to
  280. ;;; allow for sloppy mouse manipulation.  This should not produce ambiguity
  281. ;;; as long as regions are delimited by spaces, etc. An example of a region
  282. ;;; list for the string "This is a test." is given below -- assume that the
  283. ;;; symbols are really hyper-structures:
  284. ;;;   ((9 . ((14 . test)))           ; region "test" occurs in columns 10-13
  285. ;;;    (7 . ((9 . a) (14 . a-test))) ; region "a" in 8-8; "a test" in 8-13
  286. ;;;    (4 . ((7 . is)))              ; region "is" in 5-6
  287. ;;;    (-1 . ((4 . This))))          ; region "This" in 0-3
  288. ;;; Note that this includes nested regions for illustrative purposes.
  289. ;;; The structure of the table is as follows.  The outer list indexes in
  290. ;;; decreasing order the start columns of the regions.  The appropriate
  291. ;;; sub-list is identified by finding the largest sublist index which is
  292. ;;; smaller than the start of the range the user selected.  Then, since 
  293. ;;; several regions may start at the same column, a similar search is 
  294. ;;; conducted in the sublist.  These entries are in increasing order of
  295. ;;; the end column of the region, and the smallest index which is larger
  296. ;;; than the end column of the selected region is chosen.  The CDR of this
  297. ;;; entry is the hyper-structure to be used.
  298.  
  299. ;;; These are needed to build the lists.
  300. (eval-when (compile eval)
  301.  
  302.   (defmacro INSERT-CONS-INCREASING (the-cons the-list)
  303.     `(setf ,the-list (merge 'list (list ,the-cons) ,the-list 
  304.                             #'(lambda (cons1 cons2)
  305.                                 (declare (cons cons1 cons2))
  306.                                 (< (car cons1) (car cons2))))))
  307.  
  308.   (defmacro INSERT-CONS-DECREASING (the-cons the-list)
  309.     `(setf ,the-list (merge 'list (list ,the-cons) ,the-list 
  310.                             #'(lambda (cons1 cons2)
  311.                                 (declare (cons cons1 cons2))
  312.                                 (> (car cons1) (car cons2))))))
  313.   ) ; eval-when
  314.  
  315. ;;; The fundamental construction operation.  It is assumed that the start
  316. ;;; and end values are already adjusted for the padding of 1 column.
  317.  
  318. (defun ADD-REGION (region-start region-end region-structure region-list)
  319.   (declare (fixnum region-start region-end) (list region-list)
  320.            (type hyper-structure region-structure)
  321.            (optimize (safety 1) (space 2) (speed 3)))
  322.   (let ((existing-sublist (assoc region-start region-list))
  323.         (region-entry (cons region-end region-structure)))
  324.     (declare (list existing-sublist) (cons region-entry))
  325.     (if existing-sublist
  326.       (insert-cons-increasing region-entry (cdr existing-sublist))
  327.       (insert-cons-decreasing (cons region-start (list region-entry)) 
  328.                               region-list))
  329.     region-list))
  330.  
  331. ;;; Search function for finding the appropriate region given start and end.
  332. ;;; @ BUG: If the start is in one sub-structure and the end in another sub
  333. ;;; structure, this returns nil even though there may be an enclosing super
  334. ;;; structure. Reason: it goes into the subentry indexed by the first sub's
  335. ;;; start position, but there is then no entry >= end in that subtable
  336. ;;; because the end is beyond its range.  On this sort of failure, need to
  337. ;;; back down one entry in the table and try again (repeatedly).  I "fixed"
  338. ;;; this with the hack of decrementing range-start and calling the search
  339. ;;; function recursively, repeating until range-start reaches 0 or the call
  340. ;;; returns a non-null region.  THE REAL SOLUTION is to have each list in 
  341. ;;; the table continued by the previous list -- that is, to hack the list
  342. ;;; structure at creation time so the search-region-table algorithm WITHOUT
  343. ;;; the recursive call hack works correctly by following a pointer to the
  344. ;;; previous list without knowing it. 
  345.  
  346. (defun SEARCH-REGION-TABLE (range-start range-end region-table)
  347.   (declare (fixnum range-start range-end) (list region-table)
  348.            (optimize (safety 1) (space 2) (speed 3)))
  349.   (let ((ptr region-table))
  350.     (declare (list ptr))
  351.     ;; Search for appropriate subtable (list): the largest entry <= start.
  352.     (loop 
  353.       (cond ((null ptr) (return))
  354.             ((<= (car (first ptr)) range-start)
  355.              (setq ptr (cdr (first ptr)))
  356.              (return))
  357.             (T (setq ptr (cdr ptr)))))
  358.     ;; Search for appropriate entry in subtable: smallest entry >= end.
  359.     (loop
  360.       (cond ((null ptr) (return))
  361.             ((>= (car (first ptr)) range-end)
  362.              (setq ptr (cdr (first ptr)))
  363.              (return))
  364.             (T (setq ptr (cdr ptr)))))
  365.     (or ptr 
  366.         (if (> range-start 0) ; @ temporary fix, see comment above
  367.           (search-region-table (1- range-start) range-end region-table)))))
  368.  
  369. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  370. ;;; Hyper-Display Windows
  371. ;;;
  372. ;;; These are Fred windows with the following changes:
  373. ;;; * Additional user-definable object-variables:
  374. ;;;   - HYPER-STRUCTURE: the top level structure displayed in the window.
  375. ;;;   - RIGHT-MARGIN: used to format text generated from hyper-structure.
  376. ;;;   - MINI-BUFFER-MESSAGE: displayed in the mini-buffer to tell the 
  377. ;;;     user how to proceed.
  378. ;;;   - MENU-MESSAGE: title for menu of available commands.
  379. ;;; * Additional internal object-variables:
  380. ;;;   - COMMAND-TABLE: hash table constructed from the given command-list.
  381. ;;;   - REGION-TABLE: for identifying selected region; see above.
  382. ;;; * All operations which modify the contents of the buffer are disabled.
  383. ;;; * Specified command keys invoke commands on the selected region.
  384.  
  385. (defobject *HYPER-DISPLAY-WINDOW* *fred-window*)
  386.  
  387. (defobfun (EXIST *Hyper-Display-window*) (init-list)
  388.   (declare (object-variable command-table 
  389.                             hyper-structure 
  390.                             mini-buffer-selected-message
  391.                             mini-buffer-unselected-message
  392.                             general-instructions
  393.                             region-table))
  394.   (let ((hyper-structure 
  395.          (getf init-list :hyper-structure (make-hyper-structure)))
  396.         (command-list (getf init-list :command-list nil))
  397.         (right-margin 
  398.          (getf init-list :right-margin *default-right-margin*))
  399.         (menu-message 
  400.          (getf init-list :menu-message *default-menu-message*))
  401.         (mini-buffer-selected-message 
  402.          (getf init-list :mini-buffer-selected-message 
  403.                *default-mini-buffer-selected-message*))
  404.         (mini-buffer-unselected-message
  405.          (getf init-list :mini-buffer-unselected-message 
  406.                *default-mini-buffer-unselected-message*))
  407.         (general-instructions
  408.          (getf init-list :general-instructions
  409.                *default-general-instructions*)))
  410.     (check-type right-margin fixnum)
  411.     (check-type menu-message string)
  412.     (check-type mini-buffer-selected-message string)
  413.     (check-type mini-buffer-unselected-message string)
  414.     (check-type general-instructions string)
  415.     ;; These must be done first in case :window-show is specified T by user.
  416.     ;; That causes display to occur early: the methods expect these to be "had".
  417.     (have 'hyper-structure hyper-structure)
  418.     (have 'region-table nil)                ; temporary (until text displayed)
  419.     (have 'command-table (make-hash-table)) ; keystrokes to (<string> <function>)
  420.     (have 'right-margin right-margin)
  421.     (have 'menu-message menu-message)
  422.     (have 'mini-buffer-selected-message mini-buffer-selected-message)
  423.     (have 'mini-buffer-unselected-message mini-buffer-unselected-message)
  424.     (have 'general-instructions general-instructions)
  425.     ;; Now it is safe to make the thing exist as a Fred Window.
  426.     (usual-exist
  427.      (init-list-default
  428.       init-list
  429.       :window-title     (format nil "Hyper Display ~A"
  430.                                 (incf *window-name-counter*))
  431.       :package *hyper-display-package*
  432.       ;; Position and size inherited from Fred.
  433.       :window-show      nil
  434.       :window-font     '("monaco" 12)
  435.       :window-type     :document-with-zoom
  436.       :close-box       t))
  437.     ;; Set up the command tables; compute text (put in buffer) and region table.
  438.     (set-command-table command-list)
  439.     (layout-hyper-display)
  440.     (set-mini-buffer mini-buffer-unselected-message)
  441.     ;; Now show it, unless user specified not to.
  442.     (if (getf init-list :window-show t) (window-show))
  443.     ;; Return object created.
  444.     (self)))
  445.  
  446. ;;;------------------------------------------------------------------------
  447. ;;; These are needed to keep the message in the mini-buffer.  They call the
  448. ;;; corresponding usual method (which writes size or position change message
  449. ;;; into the buffer), then rewrite the desired message into the buffer.
  450.  
  451. (defobfun (SET-WINDOW-SIZE *Hyper-Display-window*) (h &optional (v nil))
  452.   (declare (object-variable mini-buffer-selected-message
  453.                             mini-buffer-unselected-message))
  454.   (funcall (ask *fred-window* (symbol-function 'set-window-size)) h v)
  455.   (multiple-value-bind (start end) (selection-range)
  456.     (declare (fixnum start end))
  457.     (if (= start end)
  458.       (set-mini-buffer mini-buffer-unselected-message)
  459.       (set-mini-buffer mini-buffer-selected-message))))
  460.  
  461. (defobfun (SET-WINDOW-POSITION *Hyper-Display-window*) (h &optional (v nil))
  462.   (declare (object-variable mini-buffer-selected-message
  463.                             mini-buffer-unselected-message))
  464.   (funcall (ask *fred-window* (symbol-function 'set-window-position)) h v)
  465.   (multiple-value-bind (start end) (selection-range)
  466.     (declare (fixnum start end))
  467.     (if (= start end)
  468.       (set-mini-buffer mini-buffer-unselected-message)
  469.       (set-mini-buffer mini-buffer-selected-message))))
  470.  
  471. ;;;------------------------------------------------------------------------
  472. ;;; Some standard methods are redefined to prevent modification of the text.
  473.  
  474. (eval-when (compile eval) ; this is used by window-key-event-handler also
  475.   (defmacro INFORM-READ-ONLY ()
  476.     ;; Used to warn the user in response to undefined keystrokes or attempts
  477.     ;; to modify the buffer.
  478.     `(progn
  479.        (ccl:ed-beep)
  480.        (wind:message-dialogue ,*read-only-message*)))
  481.   )
  482.  
  483. (defobfun (CUT *Hyper-Display-window*) () (inform-read-only))
  484. (defobfun (PASTE *Hyper-Display-window*) () (inform-read-only))
  485.  
  486. ;;;------------------------------------------------------------------------
  487. ;;; Methods for building and modifying Hyper-Display data structures.
  488.  
  489. (defobfun (SET-HYPER-STRUCTURE *Hyper-Display-window*) (structure)
  490.   (declare (object-variable hyper-structure region-table))
  491.   (buffer-delete (window-buffer) 
  492.                  :start 0
  493.                  :length (buffer-size (window-buffer)))
  494.   (setq hyper-structure structure)
  495.   (layout-hyper-display)
  496.   structure)
  497.  
  498. (defobfun (SET-COMMAND-TABLE *Hyper-Display-window*) (command-list)
  499.   ;; Command list of form ((<char> <string> <function>)*).
  500.   ;; Hash table associates <char> to (<string> <function>), except
  501.   ;; that <char> of #\^E (Help key) has a list of all known
  502.   ;; (<string> <function>) tuples, regardless of whether recorded
  503.   ;; under a key.
  504.   (declare (object-variable command-table) (list command-list)
  505.            (optimize (safety 1) (space 2) (speed 3)))
  506.   (clrhash command-table)
  507.   ;; Record all commands in order given, for menu specification,
  508.   ;; followed by menu-only command which lists keystrokes for commands.
  509.   (setf (gethash #\^E command-table) 
  510.         (nconc (mapcar #'rest command-list)
  511.                (list `("Show Keystrokes for Commands"
  512.                        (lambda (hs hd) (declare (ignore hs hd))
  513.                                (wind:message-dialogue 
  514.                                 ,(format nil "Keystrokes and Commands:~:{~%~A  ~A~}"
  515.                                          (remove #\^E command-list :key #'first))))))))
  516.   ;; Record those having a key other than the help key under their keys.
  517.   (dolist (command-spec command-list)
  518.     (declare (list command-spec))
  519.     (unless (char= (first command-spec) #\^E)
  520.       (setf (gethash (first command-spec) command-table)
  521.             (rest command-spec)))))
  522.  
  523. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  524. ;;;
  525. ;;;                     MAJOR INTERNAL FUNCTIONALITY
  526. ;;;
  527. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  528.  
  529. (defobfun (LAYOUT-HYPER-DISPLAY *Hyper-Display-Window*) ()
  530.   (declare (object-variable hyper-structure region-table right-margin)
  531.            (list region-table) (fixnum right-margin))
  532.   (multiple-value-bind
  533.     (region-list buffer-string fill-column)
  534.     (compute-regions hyper-structure '() "" 0)
  535.     (declare (list region-list) (string buffer-string) 
  536.              (fixnum fill-column)
  537.              (optimize (safety 1) (space 2) (speed 3)))
  538.     (setf region-table region-list)
  539.     ;; Record start and end of top level structure's selection region.
  540.     (setf (hyper-structure-selection-start hyper-structure) 0)
  541.     (setf (hyper-structure-selection-end   hyper-structure) (1- fill-column))
  542.     ;; Insert the string.  Note this assumes an empty buffer.
  543.     (buffer-insert (window-buffer) 
  544.                    (wind:trim-right-margin buffer-string right-margin) 
  545.                    0)))
  546.  
  547. ;;; Function for constructing the region-tables.
  548. ;;; Returns three values: a constructed region-table (called region-list to
  549. ;;; avoid confusion with an object variable) for the structure, a string 
  550. ;;; containing the text of the structure's region, and the fill-column at
  551. ;;; which concatenation to that string would continue (i.e. the length of
  552. ;;; the string).  Padding around regions is handled here.
  553.  
  554. (defun COMPUTE-REGIONS (structure region-list buffer-string initial-fill-column)
  555.   (declare (type hyper-structure structure) (list region-list)
  556.            (string buffer-string) (fixnum initial-fill-column)
  557.            (optimize (safety 1) (space 2) (speed 3)))
  558.   ;; Iterate down text-specs to construct the tree & text at this level.
  559.   (do ((spec-ptr (hyper-structure-text-specs structure) (cdr spec-ptr))
  560.        (fill-column initial-fill-column))
  561.       ((null spec-ptr) (values region-list buffer-string fill-column))
  562.     (declare (list spec-ptr) (fixumn fill-column))
  563.     (cond 
  564.      ;; Strings are just appended to the buffer, with no region construction.
  565.      ((stringp (first spec-ptr))
  566.       (setq buffer-string (concatenate 'string buffer-string (first spec-ptr)))
  567.       (incf fill-column (length (first spec-ptr))))
  568.      (t
  569.       ;; Subregions handled by building text into buffer recursively, then 
  570.       ;; recording the region in the table after we know where the region ends.
  571.       (let ((subregion-start (max (1- fill-column) 0))) ; save padded beginning
  572.         (declare (fixnum subregion-start))
  573.         (multiple-value-setq
  574.          (region-list buffer-string fill-column)
  575.          (compute-regions (first spec-ptr) region-list buffer-string fill-column))
  576.         ;; Record the range in the region structure itself, and in the table.
  577.         (setf (hyper-structure-selection-start (first spec-ptr)) subregion-start)
  578.         (setf (hyper-structure-selection-end   (first spec-ptr)) fill-column)
  579.         (setq region-list 
  580.               (add-region subregion-start fill-column ; already 1+ the region end
  581.                           (first spec-ptr) region-list)))))))
  582.  
  583. ;;; Redefine low-level keystroke handling to bypass Fred's comtabs and invoke
  584. ;;; our own legal command keys, or notify user if undefined key used.
  585.  
  586. (defobfun (WINDOW-KEY-EVENT-HANDLER *Hyper-Display-window*) (c)
  587.   (declare (object-variable command-table general-instructions menu-message
  588.                             mini-buffer-unselected-message (self))
  589.            (optimize (safety 1) (space 2) (speed 3)))
  590.   (cond 
  591.  
  592.    ((char= c #\^E) ; Help key.
  593.     ;; If there is no selection, put up general instructions.  Otherwise, 
  594.     ;; Put up a menu of actions (documentation strings are in the first
  595.     ;; position) and call the selected function (second position) on the 
  596.     ;; selected sub-structure.  (All commands were stored under #\^E.)
  597.     (multiple-value-bind (start end) (selection-range)
  598.       (declare (fixnum start end))
  599.       (if (= start end)
  600.         (wind:message-dialogue general-instructions)
  601.         (funcall
  602.          (second (assoc (wind:menu-dialogue
  603.                          (mapcar #'first (gethash #\^E command-table))
  604.                          menu-message)
  605.                         (gethash #\^E command-table)))
  606.          (selected-hyper-structure)
  607.          (self)))))
  608.  
  609.    ((member c '(#\ #\ #\ #\ #\  #\ ))
  610.     ;; Let left, right, up, down arrows, page-up, and page-down be 
  611.     ;; interpreted by Fred normally.
  612.     (funcall (ask *fred-window* (symbol-function 'window-key-event-handler)) 
  613.              c (self))
  614.     (set-mini-buffer mini-buffer-unselected-message))
  615.  
  616.     (T
  617.      ;; Other keys only legal if found in command table.
  618.      (let ((command-entry (gethash c command-table)))
  619.        (declare (list command-entry))
  620.        (if command-entry 
  621.          (funcall (second command-entry) (selected-hyper-structure) (self))
  622.          (inform-read-only))))))
  623.  
  624. ;;; Identifying the smallest hyper-structure which encloses selected region
  625. ;;; or follows the cursor.  If none found, it is the whole text.
  626.  
  627. (defobfun (SELECTED-HYPER-STRUCTURE *Hyper-Display-Window*) ()
  628.   (declare (object-variable region-table hyper-structure)
  629.            (optimize (safety 1) (space 2) (speed 3)))
  630.   (multiple-value-bind 
  631.     (start end) (selection-range)
  632.     (declare (fixnum start end))
  633.     (decf end) ; it should point to last used, not the one after.
  634.     (or (search-region-table start end region-table) hyper-structure)))
  635.  
  636. ;;; When the user releases the mouse, the selection is expanded to show
  637. ;;; the user what the selected region is.  BUG in CCL: only activated
  638. ;;; when mouse in the mini-buffer!  Maybe this is OK?
  639.  
  640. (defobfun (WINDOW-MOUSE-UP-EVENT-HANDLER *Hyper-Display-Window*) ()
  641.   (declare (object-variable mini-buffer-selected-message 
  642.                             mini-buffer-unselected-message))
  643.   (let ((hyper-structure (selected-hyper-structure)))
  644.     (set-mark (window-cursor-mark) 
  645.               (hyper-structure-selection-start hyper-structure))
  646.     (set-selection-range
  647.      ;; Special case guards against selecting off end of buffer.
  648.      (if (= (buffer-size (window-buffer))
  649.             (hyper-structure-selection-end hyper-structure))
  650.        (hyper-structure-selection-end hyper-structure)
  651.        (1+ (hyper-structure-selection-end hyper-structure))))
  652.     (set-mini-buffer mini-buffer-selected-message)))
  653.  
  654. ;;; Define this to highlight contained region when double clicked.
  655.  
  656. (defobfun (WINDOW-CLICK-EVENT-HANDLER *Hyper-Display-Window*) (where)
  657.   (declare (fixnum where)
  658.            (object-variable mini-buffer-selected-message 
  659.                             mini-buffer-unselected-message))
  660.   (if (double-click-p) 
  661.     (let ((hyper-structure (selected-hyper-structure)))
  662.       (set-mark (window-cursor-mark) 
  663.                 (hyper-structure-selection-start hyper-structure))
  664.       (set-selection-range 
  665.        ;; Special case guards against selecting off end of buffer.
  666.        (if (= (buffer-size (window-buffer))
  667.               (hyper-structure-selection-end hyper-structure))
  668.          (hyper-structure-selection-end hyper-structure)
  669.          (1+ (hyper-structure-selection-end hyper-structure))))
  670.       (set-mini-buffer mini-buffer-selected-message))
  671.     (progn 
  672.       (set-mini-buffer mini-buffer-unselected-message)
  673.       (funcall (ask *fred-window* (symbol-function 'window-click-event-handler))
  674.                where))))
  675.  
  676. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  677. ;;;
  678. ;;;                           EXPORTED FUNCTIONS
  679. ;;;
  680. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  681.  
  682. (defun CREATE-HYPER-DISPLAY (text-structure command-list &rest init-list)
  683.   "create-hyper-display <hyper-structure> <command-list> 
  684.                         &rest <keyword-args>
  685.                                           [*Hyper-Display-Window* Function]
  686.   Creates a Hyper-Display window with text and commands as specified.
  687.   The <keyword-args> can be any keyword/value pairs defined for Fred 
  688.   windows (eg. :window-size, :window-position, :window-title ...), 
  689.   plus the following additions:
  690.     :right-margin - fixnum indicating the maximum width of each line of
  691.       text generated from the <hyper-structure>.
  692.     :menu-message - string labeling the pop-up menu of commands.
  693.     :mini-buffer-selected-message
  694.     :mini-buffer-unselected-message - strings displayed in the mini-buffer
  695.       when there is and isn't a selection, respectively.  These should 
  696.       remind the user how the display is used.
  697.     :general-instructions - string displayed when user asks for help
  698.       when there is no selection.
  699.   The created window object is returned."
  700.   (check-type text-structure hyper-structure)
  701.   (check-type command-list list)
  702.   (assert (evenp (length init-list)) (init-list)
  703.           "Bad keyword/argument list (odd number of elements):~%~S" init-list)
  704.   (do ((init-ptr init-list (cddr init-ptr)))
  705.       ((null init-ptr))
  706.     (assert (typep (first init-ptr) 'keyword) (init-list)
  707.             "Non-keyword where keyword expected:~%~S" (first init-ptr)))
  708.   (apply #'oneof *hyper-display-window* 
  709.          :hyper-structure text-structure
  710.          :command-list   command-list
  711.          init-list))
  712.                         
  713. (defun DISPLAY-HYPER-STRUCTURE (text-structure hyper-display-window)
  714.   "display-hyper-structure <hyper-structure> <hyper-display-window>
  715.                                           [*Hyper-Display-Window* Function]
  716.   Changes the hyper-structure of the window to the indicated structure,
  717.   and displays the corresponding text."
  718.   (check-type text-structure hyper-structure)
  719.   (assert (typep hyper-display-window *hyper-display-window*)
  720.           (hyper-display-window) "~S is not a *hyper-display-window*")
  721.   (ask hyper-display-window 
  722.     (set-hyper-structure text-structure)
  723.     (window-update)))
  724.  
  725. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  726. (provide :Hyper-Display)
  727. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  728. ;;; The End.